home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / f2c-9510.000 / f2c-9510 / f2c-951007-libs-1.1 / src / intr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-10-07  |  19.8 KB  |  880 lines
  1. /****************************************************************
  2. Copyright 1990, 1992, 1994-5 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. #include "defs.h"
  25. #include "names.h"
  26.  
  27. union
  28.     {
  29.     int ijunk;
  30.     struct Intrpacked bits;
  31.     } packed;
  32.  
  33. struct Intrbits
  34.     {
  35.     char intrgroup /* :3 */;
  36.     char intrstuff /* result type or number of generics */;
  37.     char intrno /* :7 */;
  38.     char dblcmplx;
  39.     char dblintrno;    /* for -r8 */
  40.     };
  41.  
  42. /* List of all intrinsic functions.  */
  43.  
  44. LOCAL struct Intrblock
  45.     {
  46.     char intrfname[8];
  47.     struct Intrbits intrval;
  48.     } intrtab[ ] =
  49. {
  50. "int",         { INTRCONV, TYLONG },
  51. "real",     { INTRCONV, TYREAL, 1 },
  52.         /* 1 ==> real(TYDCOMPLEX) yields TYDREAL */
  53. "dble",     { INTRCONV, TYDREAL },
  54. "cmplx",     { INTRCONV, TYCOMPLEX },
  55. "dcmplx",     { INTRCONV, TYDCOMPLEX, 0, 1 },
  56. "ifix",     { INTRCONV, TYLONG },
  57. "idint",     { INTRCONV, TYLONG },
  58. "float",     { INTRCONV, TYREAL },
  59. "dfloat",    { INTRCONV, TYDREAL },
  60. "sngl",     { INTRCONV, TYREAL },
  61. "ichar",     { INTRCONV, TYLONG },
  62. "iachar",     { INTRCONV, TYLONG },
  63. "char",     { INTRCONV, TYCHAR },
  64. "achar",     { INTRCONV, TYCHAR },
  65.  
  66. /* any MAX or MIN can be used with any types; the compiler will cast them
  67.    correctly.  So rules against bad syntax in these expressions are not
  68.    enforced */
  69.  
  70. "max",         { INTRMAX, TYUNKNOWN },
  71. "max0",     { INTRMAX, TYLONG },
  72. "amax0",     { INTRMAX, TYREAL },
  73. "max1",     { INTRMAX, TYLONG },
  74. "amax1",     { INTRMAX, TYREAL },
  75. "dmax1",     { INTRMAX, TYDREAL },
  76.  
  77. "and",        { INTRBOOL, TYUNKNOWN, OPBITAND },
  78. "or",        { INTRBOOL, TYUNKNOWN, OPBITOR },
  79. "xor",        { INTRBOOL, TYUNKNOWN, OPBITXOR },
  80. "not",        { INTRBOOL, TYUNKNOWN, OPBITNOT },
  81. "lshift",    { INTRBOOL, TYUNKNOWN, OPLSHIFT },
  82. "rshift",    { INTRBOOL, TYUNKNOWN, OPRSHIFT },
  83.  
  84. "min",         { INTRMIN, TYUNKNOWN },
  85. "min0",     { INTRMIN, TYLONG },
  86. "amin0",     { INTRMIN, TYREAL },
  87. "min1",     { INTRMIN, TYLONG },
  88. "amin1",     { INTRMIN, TYREAL },
  89. "dmin1",     { INTRMIN, TYDREAL },
  90.  
  91. "aint",     { INTRGEN, 2, 0 },
  92. "dint",     { INTRSPEC, TYDREAL, 1 },
  93.  
  94. "anint",     { INTRGEN, 2, 2 },
  95. "dnint",     { INTRSPEC, TYDREAL, 3 },
  96.  
  97. "nint",     { INTRGEN, 4, 4 },
  98. "idnint",     { INTRGEN, 2, 6 },
  99.  
  100. "abs",         { INTRGEN, 6, 8 },
  101. "iabs",     { INTRGEN, 2, 9 },
  102. "dabs",     { INTRSPEC, TYDREAL, 11 },
  103. "cabs",     { INTRSPEC, TYREAL, 12, 0, 13 },
  104. "zabs",     { INTRSPEC, TYDREAL, 13, 1 },
  105.  
  106. "mod",         { INTRGEN, 4, 14 },
  107. "amod",     { INTRSPEC, TYREAL, 16, 0, 17 },
  108. "dmod",     { INTRSPEC, TYDREAL, 17 },
  109.  
  110. "sign",     { INTRGEN, 4, 18 },
  111. "isign",     { INTRGEN, 2, 19 },
  112. "dsign",     { INTRSPEC, TYDREAL, 21 },
  113.  
  114. "dim",         { INTRGEN, 4, 22 },
  115. "idim",     { INTRGEN, 2, 23 },
  116. "ddim",     { INTRSPEC, TYDREAL, 25 },
  117.  
  118. "dprod",     { INTRSPEC, TYDREAL, 26 },
  119.  
  120. "len",         { INTRSPEC, TYLONG, 27 },
  121. "index",     { INTRSPEC, TYLONG, 29 },
  122.  
  123. "imag",     { INTRGEN, 2, 31 },
  124. "aimag",     { INTRSPEC, TYREAL, 31, 0, 32 },
  125. "dimag",     { INTRSPEC, TYDREAL, 32 },
  126.  
  127. "conjg",     { INTRGEN, 2, 33 },
  128. "dconjg",     { INTRSPEC, TYDCOMPLEX, 34, 1 },
  129.  
  130. "sqrt",     { INTRGEN, 4, 35 },
  131. "dsqrt",     { INTRSPEC, TYDREAL, 36 },
  132. "csqrt",     { INTRSPEC, TYCOMPLEX, 37, 0, 38 },
  133. "zsqrt",     { INTRSPEC, TYDCOMPLEX, 38, 1 },
  134.  
  135. "exp",         { INTRGEN, 4, 39 },
  136. "dexp",     { INTRSPEC, TYDREAL, 40 },
  137. "cexp",     { INTRSPEC, TYCOMPLEX, 41, 0, 42 },
  138. "zexp",     { INTRSPEC, TYDCOMPLEX, 42, 1 },
  139.  
  140. "log",         { INTRGEN, 4, 43 },
  141. "alog",     { INTRSPEC, TYREAL, 43, 0, 44 },
  142. "dlog",     { INTRSPEC, TYDREAL, 44 },
  143. "clog",     { INTRSPEC, TYCOMPLEX, 45, 0, 46 },
  144. "zlog",     { INTRSPEC, TYDCOMPLEX, 46, 1 },
  145.  
  146. "log10",     { INTRGEN, 2, 47 },
  147. "alog10",     { INTRSPEC, TYREAL, 47, 0, 48 },
  148. "dlog10",     { INTRSPEC, TYDREAL, 48 },
  149.  
  150. "sin",         { INTRGEN, 4, 49 },
  151. "dsin",     { INTRSPEC, TYDREAL, 50 },
  152. "csin",     { INTRSPEC, TYCOMPLEX, 51, 0, 52 },
  153. "zsin",     { INTRSPEC, TYDCOMPLEX, 52, 1 },
  154.  
  155. "cos",         { INTRGEN, 4, 53 },
  156. "dcos",     { INTRSPEC, TYDREAL, 54 },
  157. "ccos",     { INTRSPEC, TYCOMPLEX, 55, 0, 56 },
  158. "zcos",     { INTRSPEC, TYDCOMPLEX, 56, 1 },
  159.  
  160. "tan",         { INTRGEN, 2, 57 },
  161. "dtan",     { INTRSPEC, TYDREAL, 58 },
  162.  
  163. "asin",     { INTRGEN, 2, 59 },
  164. "dasin",     { INTRSPEC, TYDREAL, 60 },
  165.  
  166. "acos",     { INTRGEN, 2, 61 },
  167. "dacos",     { INTRSPEC, TYDREAL, 62 },
  168.  
  169. "atan",     { INTRGEN, 2, 63 },
  170. "datan",     { INTRSPEC, TYDREAL, 64 },
  171.  
  172. "atan2",     { INTRGEN, 2, 65 },
  173. "datan2",     { INTRSPEC, TYDREAL, 66 },
  174.  
  175. "sinh",     { INTRGEN, 2, 67 },
  176. "dsinh",     { INTRSPEC, TYDREAL, 68 },
  177.  
  178. "cosh",     { INTRGEN, 2, 69 },
  179. "dcosh",     { INTRSPEC, TYDREAL, 70 },
  180.  
  181. "tanh",     { INTRGEN, 2, 71 },
  182. "dtanh",     { INTRSPEC, TYDREAL, 72 },
  183.  
  184. "lge",        { INTRSPEC, TYLOGICAL, 73},
  185. "lgt",        { INTRSPEC, TYLOGICAL, 75},
  186. "lle",        { INTRSPEC, TYLOGICAL, 77},
  187. "llt",        { INTRSPEC, TYLOGICAL, 79},
  188.  
  189. #if 0
  190. "epbase",    { INTRCNST, 4, 0 },
  191. "epprec",    { INTRCNST, 4, 4 },
  192. "epemin",    { INTRCNST, 2, 8 },
  193. "epemax",    { INTRCNST, 2, 10 },
  194. "eptiny",    { INTRCNST, 2, 12 },
  195. "ephuge",    { INTRCNST, 4, 14 },
  196. "epmrsp",    { INTRCNST, 2, 18 },
  197. #endif
  198.  
  199. "fpexpn",    { INTRGEN, 4, 81 },
  200. "fpabsp",    { INTRGEN, 2, 85 },
  201. "fprrsp",    { INTRGEN, 2, 87 },
  202. "fpfrac",    { INTRGEN, 2, 89 },
  203. "fpmake",    { INTRGEN, 2, 91 },
  204. "fpscal",    { INTRGEN, 2, 93 },
  205.  
  206. "" };
  207.  
  208.  
  209. LOCAL struct Specblock
  210.     {
  211.     char atype;        /* Argument type; every arg must have
  212.                    this type */
  213.     char rtype;        /* Result type */
  214.     char nargs;        /* Number of arguments */
  215.     char spxname[8];    /* Name of the function in Fortran */
  216.     char othername;        /* index into callbyvalue table */
  217.     } spectab[ ] =
  218. {
  219.     { TYREAL,TYREAL,1,"r_int" },
  220.     { TYDREAL,TYDREAL,1,"d_int" },
  221.  
  222.     { TYREAL,TYREAL,1,"r_nint" },
  223.     { TYDREAL,TYDREAL,1,"d_nint" },
  224.  
  225.     { TYREAL,TYSHORT,1,"h_nint" },
  226.     { TYREAL,TYLONG,1,"i_nint" },
  227.  
  228.     { TYDREAL,TYSHORT,1,"h_dnnt" },
  229.     { TYDREAL,TYLONG,1,"i_dnnt" },
  230.  
  231.     { TYREAL,TYREAL,1,"r_abs" },
  232.     { TYSHORT,TYSHORT,1,"h_abs" },
  233.     { TYLONG,TYLONG,1,"i_abs" },
  234.     { TYDREAL,TYDREAL,1,"d_abs" },
  235.     { TYCOMPLEX,TYREAL,1,"c_abs" },
  236.     { TYDCOMPLEX,TYDREAL,1,"z_abs" },
  237.  
  238.     { TYSHORT,TYSHORT,2,"h_mod" },
  239.     { TYLONG,TYLONG,2,"i_mod" },
  240.     { TYREAL,TYREAL,2,"r_mod" },
  241.     { TYDREAL,TYDREAL,2,"d_mod" },
  242.  
  243.     { TYREAL,TYREAL,2,"r_sign" },
  244.     { TYSHORT,TYSHORT,2,"h_sign" },
  245.     { TYLONG,TYLONG,2,"i_sign" },
  246.     { TYDREAL,TYDREAL,2,"d_sign" },
  247.  
  248.     { TYREAL,TYREAL,2,"r_dim" },
  249.     { TYSHORT,TYSHORT,2,"h_dim" },
  250.     { TYLONG,TYLONG,2,"i_dim" },
  251.     { TYDREAL,TYDREAL,2,"d_dim" },
  252.  
  253.     { TYREAL,TYDREAL,2,"d_prod" },
  254.  
  255.     { TYCHAR,TYSHORT,1,"h_len" },
  256.     { TYCHAR,TYLONG,1,"i_len" },
  257.  
  258.     { TYCHAR,TYSHORT,2,"h_indx" },
  259.     { TYCHAR,TYLONG,2,"i_indx" },
  260.  
  261.     { TYCOMPLEX,TYREAL,1,"r_imag" },
  262.     { TYDCOMPLEX,TYDREAL,1,"d_imag" },
  263.     { TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" },
  264.     { TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" },
  265.  
  266.     { TYREAL,TYREAL,1,"r_sqrt", 1 },
  267.     { TYDREAL,TYDREAL,1,"d_sqrt", 1 },
  268.     { TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" },
  269.     { TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" },
  270.  
  271.     { TYREAL,TYREAL,1,"r_exp", 2 },
  272.     { TYDREAL,TYDREAL,1,"d_exp", 2 },
  273.     { TYCOMPLEX,TYCOMPLEX,1,"c_exp" },
  274.     { TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" },
  275.  
  276.     { TYREAL,TYREAL,1,"r_log", 3 },
  277.     { TYDREAL,TYDREAL,1,"d_log", 3 },
  278.     { TYCOMPLEX,TYCOMPLEX,1,"c_log" },
  279.     { TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },
  280.  
  281.     { TYREAL,TYREAL,1,"r_lg10" },
  282.     { TYDREAL,TYDREAL,1,"d_lg10" },
  283.  
  284.     { TYREAL,TYREAL,1,"r_sin", 4 },
  285.     { TYDREAL,TYDREAL,1,"d_sin", 4 },
  286.     { TYCOMPLEX,TYCOMPLEX,1,"c_sin" },
  287.     { TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" },
  288.  
  289.     { TYREAL,TYREAL,1,"r_cos", 5 },
  290.     { TYDREAL,TYDREAL,1,"d_cos", 5 },
  291.     { TYCOMPLEX,TYCOMPLEX,1,"c_cos" },
  292.     { TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" },
  293.  
  294.     { TYREAL,TYREAL,1,"r_tan", 6 },
  295.     { TYDREAL,TYDREAL,1,"d_tan", 6 },
  296.  
  297.     { TYREAL,TYREAL,1,"r_asin", 7 },
  298.     { TYDREAL,TYDREAL,1,"d_asin", 7 },
  299.  
  300.     { TYREAL,TYREAL,1,"r_acos", 8 },
  301.     { TYDREAL,TYDREAL,1,"d_acos", 8 },
  302.  
  303.     { TYREAL,TYREAL,1,"r_atan", 9 },
  304.     { TYDREAL,TYDREAL,1,"d_atan", 9 },
  305.  
  306.     { TYREAL,TYREAL,2,"r_atn2", 10 },
  307.     { TYDREAL,TYDREAL,2,"d_atn2", 10 },
  308.  
  309.     { TYREAL,TYREAL,1,"r_sinh", 11 },
  310.     { TYDREAL,TYDREAL,1,"d_sinh", 11 },
  311.  
  312.     { TYREAL,TYREAL,1,"r_cosh", 12 },
  313.     { TYDREAL,TYDREAL,1,"d_cosh", 12 },
  314.  
  315.     { TYREAL,TYREAL,1,"r_tanh", 13 },
  316.     { TYDREAL,TYDREAL,1,"d_tanh", 13 },
  317.  
  318.     { TYCHAR,TYLOGICAL,2,"hl_ge" },
  319.     { TYCHAR,TYLOGICAL,2,"l_ge" },
  320.  
  321.     { TYCHAR,TYLOGICAL,2,"hl_gt" },
  322.     { TYCHAR,TYLOGICAL,2,"l_gt" },
  323.  
  324.     { TYCHAR,TYLOGICAL,2,"hl_le" },
  325.     { TYCHAR,TYLOGICAL,2,"l_le" },
  326.  
  327.     { TYCHAR,TYLOGICAL,2,"hl_lt" },
  328.     { TYCHAR,TYLOGICAL,2,"l_lt" },
  329.  
  330.     { TYREAL,TYSHORT,1,"hr_expn" },
  331.     { TYREAL,TYLONG,1,"ir_expn" },
  332.     { TYDREAL,TYSHORT,1,"hd_expn" },
  333.     { TYDREAL,TYLONG,1,"id_expn" },
  334.  
  335.     { TYREAL,TYREAL,1,"r_absp" },
  336.     { TYDREAL,TYDREAL,1,"d_absp" },
  337.  
  338.     { TYREAL,TYDREAL,1,"r_rrsp" },
  339.     { TYDREAL,TYDREAL,1,"d_rrsp" },
  340.  
  341.     { TYREAL,TYREAL,1,"r_frac" },
  342.     { TYDREAL,TYDREAL,1,"d_frac" },
  343.  
  344.     { TYREAL,TYREAL,2,"r_make" },
  345.     { TYDREAL,TYDREAL,2,"d_make" },
  346.  
  347.     { TYREAL,TYREAL,2,"r_scal" },
  348.     { TYDREAL,TYDREAL,2,"d_scal" },
  349.     { 0 }
  350. } ;
  351.  
  352. #if 0
  353. LOCAL struct Incstblock
  354.     {
  355.     char atype;
  356.     char rtype;
  357.     char constno;
  358.     } consttab[ ] =
  359. {
  360.     { TYSHORT, TYLONG, 0 },
  361.     { TYLONG, TYLONG, 1 },
  362.     { TYREAL, TYLONG, 2 },
  363.     { TYDREAL, TYLONG, 3 },
  364.  
  365.     { TYSHORT, TYLONG, 4 },
  366.     { TYLONG, TYLONG, 5 },
  367.     { TYREAL, TYLONG, 6 },
  368.     { TYDREAL, TYLONG, 7 },
  369.  
  370.     { TYREAL, TYLONG, 8 },
  371.     { TYDREAL, TYLONG, 9 },
  372.  
  373.     { TYREAL, TYLONG, 10 },
  374.     { TYDREAL, TYLONG, 11 },
  375.  
  376.     { TYREAL, TYREAL, 0 },
  377.     { TYDREAL, TYDREAL, 1 },
  378.  
  379.     { TYSHORT, TYLONG, 12 },
  380.     { TYLONG, TYLONG, 13 },
  381.     { TYREAL, TYREAL, 2 },
  382.     { TYDREAL, TYDREAL, 3 },
  383.  
  384.     { TYREAL, TYREAL, 4 },
  385.     { TYDREAL, TYDREAL, 5 }
  386. };
  387. #endif
  388.  
  389. char *callbyvalue[ ] =
  390.     {0,
  391.     "sqrt",
  392.     "exp",
  393.     "log",
  394.     "sin",
  395.     "cos",
  396.     "tan",
  397.     "asin",
  398.     "acos",
  399.     "atan",
  400.     "atan2",
  401.     "sinh",
  402.     "cosh",
  403.     "tanh"
  404.     };
  405.  
  406.  void
  407. r8fix(Void)    /* adjust tables for -r8 */
  408. {
  409.     register struct Intrblock *I;
  410.     register struct Specblock *S;
  411.  
  412.     for(I = intrtab; I->intrfname[0]; I++)
  413.         if (I->intrval.intrgroup != INTRGEN)
  414.             switch(I->intrval.intrstuff) {
  415.             case TYREAL:
  416.                 I->intrval.intrstuff = TYDREAL;
  417.                 I->intrval.intrno = I->intrval.dblintrno;
  418.                 break;
  419.             case TYCOMPLEX:
  420.                 I->intrval.intrstuff = TYDCOMPLEX;
  421.                 I->intrval.intrno = I->intrval.dblintrno;
  422.                 I->intrval.dblcmplx = 1;
  423.             }
  424.  
  425.     for(S = spectab; S->atype; S++)
  426.         switch(S->atype) {
  427.         case TYCOMPLEX:
  428.             S->atype = TYDCOMPLEX;
  429.             if (S->rtype == TYREAL)
  430.                 S->rtype = TYDREAL;
  431.             else if (S->rtype == TYCOMPLEX)
  432.                 S->rtype = TYDCOMPLEX;
  433.             switch(S->spxname[0]) {
  434.                 case 'r':
  435.                     S->spxname[0] = 'd';
  436.                     break;
  437.                 case 'c':
  438.                     S->spxname[0] = 'z';
  439.                     break;
  440.                 default:
  441.                     Fatal("r8fix bug");
  442.                 }
  443.             break;
  444.         case TYREAL:
  445.             S->atype = TYDREAL;
  446.             switch(S->rtype) {
  447.                 case TYREAL:
  448.                 S->rtype = TYDREAL;
  449.                 if (S->spxname[0] != 'r')
  450.                     Fatal("r8fix bug");
  451.                 S->spxname[0] = 'd';
  452.                 case TYDREAL:    /* d_prod */
  453.                 break;
  454.  
  455.                 case TYSHORT:
  456.                 if (!strcmp(S->spxname, "hr_expn"))
  457.                     S->spxname[1] = 'd';
  458.                 else if (!strcmp(S->spxname, "h_nint"))
  459.                     strcpy(S->spxname, "h_dnnt");
  460.                 else Fatal("r8fix bug");
  461.                 break;
  462.  
  463.                 case TYLONG:
  464.                 if (!strcmp(S->spxname, "ir_expn"))
  465.                     S->spxname[1] = 'd';
  466.                 else if (!strcmp(S->spxname, "i_nint"))
  467.                     strcpy(S->spxname, "i_dnnt");
  468.                 else Fatal("r8fix bug");
  469.                 break;
  470.  
  471.                 default:
  472.                 Fatal("r8fix bug");
  473.                 }
  474.         }
  475.     }
  476.  
  477.  
  478.  expptr
  479. #ifdef KR_headers
  480. intrcall(np, argsp, nargs)
  481.     Namep np;
  482.     struct Listblock *argsp;
  483.     int nargs;
  484. #else
  485. intrcall(Namep np, struct Listblock *argsp, int nargs)
  486. #endif
  487. {
  488.     int i, rettype;
  489.     Addrp ap;
  490.     register struct Specblock *sp;
  491.     register struct Chain *cp;
  492.     expptr q, ep;
  493.     int mtype;
  494.     int op;
  495.     int f1field, f2field, f3field;
  496.  
  497.     packed.ijunk = np->vardesc.varno;
  498.     f1field = packed.bits.f1;
  499.     f2field = packed.bits.f2;
  500.     f3field = packed.bits.f3;
  501.     if(nargs == 0)
  502.         goto badnargs;
  503.  
  504.     mtype = 0;
  505.     for(cp = argsp->listp ; cp ; cp = cp->nextp)
  506.     {
  507.         ep = (expptr)cp->datap;
  508.         if( ISCONST(ep) && ep->headblock.vtype==TYSHORT )
  509.             cp->datap = (char *) mkconv(tyint, ep);
  510.         mtype = maxtype(mtype, ep->headblock.vtype);
  511.     }
  512.  
  513.     switch(f1field)
  514.     {
  515.     case INTRBOOL:
  516.         op = f3field;
  517.         if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
  518.             goto badtype;
  519.         if(op == OPBITNOT)
  520.         {
  521.             if(nargs != 1)
  522.                 goto badnargs;
  523.             q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL);
  524.         }
  525.         else
  526.         {
  527.             if(nargs != 2)
  528.                 goto badnargs;
  529.             q = mkexpr(op, (expptr)argsp->listp->datap,
  530.                         (expptr)argsp->listp->nextp->datap);
  531.         }
  532.         frchain( &(argsp->listp) );
  533.         free( (charptr) argsp);
  534.         return(q);
  535.  
  536.     case INTRCONV:
  537.         rettype = f2field;
  538.         switch(rettype) {
  539.           case TYLONG:
  540.             rettype = tyint;
  541.             break;
  542.           case TYLOGICAL:
  543.             rettype = tylog;
  544.           }
  545.         if( ISCOMPLEX(rettype) && nargs==2)
  546.         {
  547.             expptr qr, qi;
  548.             qr = (expptr) argsp->listp->datap;
  549.             qi = (expptr) argsp->listp->nextp->datap;
  550.             if (qr->headblock.vtype == TYDREAL
  551.              || qi->headblock.vtype == TYDREAL)
  552.                 rettype = TYDCOMPLEX;
  553.             if(ISCONST(qr) && ISCONST(qi))
  554.                 q = mkcxcon(qr,qi);
  555.             else    q = mkexpr(OPCONV,mkconv(rettype-2,qr),
  556.                 mkconv(rettype-2,qi));
  557.         }
  558.         else if(nargs == 1) {
  559.             if (f3field && ((Exprp)argsp->listp->datap)->vtype
  560.                     == TYDCOMPLEX)
  561.                 rettype = TYDREAL;
  562.             q = mkconv(rettype+100, (expptr)argsp->listp->datap);
  563.             if (q->tag == TADDR)
  564.                 q->addrblock.parenused = 1;
  565.             }
  566.         else goto badnargs;
  567.  
  568.         q->headblock.vtype = rettype;
  569.         frchain(&(argsp->listp));
  570.         free( (charptr) argsp);
  571.         return(q);
  572.  
  573.  
  574. #if 0
  575.     case INTRCNST:
  576.  
  577. /* Machine-dependent f77 stuff that f2c omits:
  578.  
  579. intcon contains
  580.     radix for short int
  581.     radix for long int
  582.     radix for single precision
  583.     radix for double precision
  584.     precision for short int
  585.     precision for long int
  586.     precision for single precision
  587.     precision for double precision
  588.     emin for single precision
  589.     emin for double precision
  590.     emax for single precision
  591.     emax for double prcision
  592.     largest short int
  593.     largest long int
  594.  
  595. realcon contains
  596.     tiny for single precision
  597.     tiny for double precision
  598.     huge for single precision
  599.     huge for double precision
  600.     mrsp (epsilon) for single precision
  601.     mrsp (epsilon) for double precision
  602. */
  603.     {    register struct Incstblock *cstp;
  604.         extern ftnint intcon[14];
  605.         extern double realcon[6];
  606.  
  607.         cstp = consttab + f3field;
  608.         for(i=0 ; i<f2field ; ++i)
  609.             if(cstp->atype == mtype)
  610.                 goto foundconst;
  611.             else
  612.                 ++cstp;
  613.         goto badtype;
  614.  
  615. foundconst:
  616.         switch(cstp->rtype)
  617.         {
  618.         case TYLONG:
  619.             return(mkintcon(intcon[cstp->constno]));
  620.  
  621.         case TYREAL:
  622.         case TYDREAL:
  623.             return(mkrealcon(cstp->rtype,
  624.                 realcon[cstp->constno]) );
  625.  
  626.         default:
  627.             Fatal("impossible intrinsic constant");
  628.         }
  629.     }
  630. #endif
  631.  
  632.     case INTRGEN:
  633.         sp = spectab + f3field;
  634.         if(no66flag)
  635.             if(sp->atype == mtype)
  636.                 goto specfunct;
  637.             else err66("generic function");
  638.  
  639.         for(i=0; i<f2field ; ++i)
  640.             if(sp->atype == mtype)
  641.                 goto specfunct;
  642.             else
  643.                 ++sp;
  644.         warn1 ("bad argument type to intrinsic %s", np->fvarname);
  645.  
  646. /* Made this a warning rather than an error so things like "log (5) ==>
  647.    log (5.0)" can be accommodated.  When none of these cases matches, the
  648.    argument is cast up to the first type in the spectab list; this first
  649.    type is assumed to be the "smallest" type, e.g. REAL before DREAL
  650.    before COMPLEX, before DCOMPLEX */
  651.  
  652.         sp = spectab + f3field;
  653.         mtype = sp -> atype;
  654.         goto specfunct;
  655.  
  656.     case INTRSPEC:
  657.         sp = spectab + f3field;
  658. specfunct:
  659.         if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
  660.             && (sp+1)->atype==sp->atype)
  661.             ++sp;
  662.  
  663.         if(nargs != sp->nargs)
  664.             goto badnargs;
  665.         if(mtype != sp->atype)
  666.             goto badtype;
  667.  
  668. /* NOTE!!  I moved fixargs (YES) into the ELSE branch so that constants in
  669.    the inline expression wouldn't get put into the constant table */
  670.  
  671.         fixargs (NO, argsp);
  672.         cast_args (mtype, argsp -> listp);
  673.  
  674.         if(q = Inline((int)(sp-spectab), mtype, argsp->listp))
  675.         {
  676.             frchain( &(argsp->listp) );
  677.             free( (charptr) argsp);
  678.         } else {
  679.  
  680.             if(sp->othername) {
  681.             /* C library routines that return double... */
  682.             /* sp->rtype might be TYREAL */
  683.             ap = builtin(sp->rtype,
  684.                 callbyvalue[sp->othername], 1);
  685.             q = fixexpr((Exprp)
  686.                 mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
  687.             } else {
  688.             fixargs(YES, argsp);
  689.             ap = builtin(sp->rtype, sp->spxname, 0);
  690.             q = fixexpr((Exprp)
  691.                 mkexpr(OPCALL, (expptr)ap, (expptr)argsp) );
  692.             } /* else */
  693.         } /* else */
  694.         return(q);
  695.  
  696.     case INTRMIN:
  697.     case INTRMAX:
  698.         if(nargs < 2)
  699.             goto badnargs;
  700.         if( ! ONEOF(mtype, MSKINT|MSKREAL) )
  701.             goto badtype;
  702.         argsp->vtype = mtype;
  703.         q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), (expptr)argsp, ENULL);
  704.  
  705.         q->headblock.vtype = mtype;
  706.         rettype = f2field;
  707.         if(rettype == TYLONG)
  708.             rettype = tyint;
  709.         else if(rettype == TYUNKNOWN)
  710.             rettype = mtype;
  711.         return( mkconv(rettype, q) );
  712.  
  713.     default:
  714.         fatali("intrcall: bad intrgroup %d", f1field);
  715.     }
  716. badnargs:
  717.     errstr("bad number of arguments to intrinsic %s", np->fvarname);
  718.     goto bad;
  719.  
  720. badtype:
  721.     errstr("bad argument type to intrinsic %s", np->fvarname);
  722.  
  723. bad:
  724.     return( errnode() );
  725. }
  726.  
  727.  
  728.  
  729.  int
  730. #ifdef KR_headers
  731. intrfunct(s)
  732.     char *s;
  733. #else
  734. intrfunct(char *s)
  735. #endif
  736. {
  737.     register struct Intrblock *p;
  738.  
  739.     for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p)
  740.     {
  741.         if( !strcmp(s, p->intrfname) )
  742.         {
  743.             packed.bits.f1 = p->intrval.intrgroup;
  744.             packed.bits.f2 = p->intrval.intrstuff;
  745.             packed.bits.f3 = p->intrval.intrno;
  746.             packed.bits.f4 = p->intrval.dblcmplx;
  747.             return(packed.ijunk);
  748.         }
  749.     }
  750.  
  751.     return(0);
  752. }
  753.  
  754.  
  755.  
  756.  
  757.  
  758.  Addrp
  759. #ifdef KR_headers
  760. intraddr(np)
  761.     Namep np;
  762. #else
  763. intraddr(Namep np)
  764. #endif
  765. {
  766.     Addrp q;
  767.     register struct Specblock *sp;
  768.     int f3field;
  769.  
  770.     if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC)
  771.         fatalstr("intraddr: %s is not intrinsic", np->fvarname);
  772.     packed.ijunk = np->vardesc.varno;
  773.     f3field = packed.bits.f3;
  774.  
  775.     switch(packed.bits.f1)
  776.     {
  777.     case INTRGEN:
  778.         /* imag, log, and log10 arent specific functions */
  779.         if(f3field==31 || f3field==43 || f3field==47)
  780.             goto bad;
  781.  
  782.     case INTRSPEC:
  783.         sp = spectab + f3field;
  784.         if (tyint == TYLONG
  785.         && (sp->rtype == TYSHORT || sp->rtype == TYLOGICAL))
  786.             ++sp;
  787.         q = builtin(sp->rtype, sp->spxname,
  788.             sp->othername ? 1 : 0);
  789.         return(q);
  790.  
  791.     case INTRCONV:
  792.     case INTRMIN:
  793.     case INTRMAX:
  794.     case INTRBOOL:
  795.     case INTRCNST:
  796. bad:
  797.         errstr("cannot pass %s as actual", np->fvarname);
  798.         return((Addrp)errnode());
  799.     }
  800.     fatali("intraddr: impossible f1=%d\n", (int) packed.bits.f1);
  801.     /* NOT REACHED */ return 0;
  802. }
  803.  
  804.  
  805.  
  806.  void
  807. #ifdef KR_headers
  808. cast_args(maxtype, args)
  809.     int maxtype;
  810.     chainp args;
  811. #else
  812. cast_args(int maxtype, chainp args)
  813. #endif
  814. {
  815.     for (; args; args = args -> nextp) {
  816.     expptr e = (expptr) args->datap;
  817.     if (e -> headblock.vtype != maxtype)
  818.         if (e -> tag == TCONST)
  819.         args->datap = (char *) mkconv(maxtype, e);
  820.         else {
  821.         Addrp temp = mktmp(maxtype, ENULL);
  822.  
  823.         puteq(cpexpr((expptr)temp), e);
  824.         args->datap = (char *)temp;
  825.         } /* else */
  826.     } /* for */
  827. } /* cast_args */
  828.  
  829.  
  830.  
  831.  expptr
  832. #ifdef KR_headers
  833. Inline(fno, type, args)
  834.     int fno;
  835.     int type;
  836.     struct Chain *args;
  837. #else
  838. Inline(int fno, int type, struct Chain *args)
  839. #endif
  840. {
  841.     register expptr q, t, t1;
  842.  
  843.     switch(fno)
  844.     {
  845.     case 8:    /* real abs */
  846.     case 9:    /* short int abs */
  847.     case 10:    /* long int abs */
  848.     case 11:    /* double precision abs */
  849.         if( addressable(q = (expptr) args->datap) )
  850.         {
  851.             t = q;
  852.             q = NULL;
  853.         }
  854.         else
  855.             t = (expptr) mktmp(type,ENULL);
  856.         t1 = mkexpr(type == TYREAL && forcedouble ? OPDABS : OPABS,
  857.             cpexpr(t), ENULL);
  858.         if(q)
  859.             t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1);
  860.         frexpr(t);
  861.         return(t1);
  862.  
  863.     case 26:    /* dprod */
  864.         q = mkexpr(OPSTAR, mkconv(TYDREAL,(expptr)args->datap),
  865.             (expptr)args->nextp->datap);
  866.         return(q);
  867.  
  868.     case 27:    /* len of character string */
  869.         q = (expptr) cpexpr(((tagptr)args->datap)->headblock.vleng);
  870.         frexpr((expptr)args->datap);
  871.         return mkconv(tyioint, q);
  872.  
  873.     case 14:    /* half-integer mod */
  874.     case 15:    /* mod */
  875.         return mkexpr(OPMOD, (expptr) args->datap,
  876.                     (expptr) args->nextp->datap);
  877.     }
  878.     return(NULL);
  879. }
  880.